Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue54/Alfresco/AACrypt.pas

Pascal/Delphi Source File | 1999-12-12 | 12.3 KB | 370 lines

{*********************************************************}
{* AACrypt                                               *}
{* Copyright (c) Julian M Bucknall 1998-2000             *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Algorithms Alfresco simulated annealing unit          *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit AACrypt;

interface

uses
  SysUtils,
  Classes;

type
  TaaADFGVXTable = string[36];

procedure AACaesarCipher(aEncrypt   : boolean;
                         N          : integer;
                         aInStream  : TStream;
                         aOutStream : TStream);

procedure AAVigenereCipher(aEncrypt   : boolean;
                           aKey       : string;
                           aInStream  : TStream;
                           aOutStream : TStream);

function AAGenADFGVXTable : TaaADFGVXTable;

procedure AAADFGVXCipher(aEncrypt   : boolean;
                         aKey       : string;
                   const aSubstTable: TaaADFGVXTable;
                         aInStream  : TStream;
                         aOutStream : TStream);

procedure AAXORCipher(aKey       : PByteArray;
                      aKeyLen    : integer;
                      aInStream  : TStream;
                      aOutStream : TStream);


implementation

{====================================================================}
procedure AACaesarCipher(aEncrypt   : boolean;
                         N          : integer;
                         aInStream  : TStream;
                         aOutStream : TStream);
var
  BytesRead : longint;
  i         : integer;
  Ch        : byte;
  Buf       : array [0..255] of byte;
begin
  {force N in range 0..25}
  N := N mod 26;
  if (N < 0) then
    inc(N, 26);
  if not aEncrypt then
    N := 26 - N;
  {read through the input stream in blocks, encrypt the block, and
   write it to the output stream--only convert A-Z and a-z}
  BytesRead := aInStream.Read(Buf, sizeof(Buf));
  while (BytesRead > 0) do begin
    for i := 0 to pred(BytesRead) do begin
      Ch := Buf[i];
      if ((ord('A') <= Ch) and (Ch <= ord('Z'))) then
        Buf[i] := ((Ch - ord('A') + N) mod 26) + ord('A')
      else if ((ord('a') <= Ch) and (Ch <= ord('z'))) then
        Buf[i] := ((Ch - ord('a') + N) mod 26) + ord('a')
    end;
    aOutStream.Write(Buf, BytesRead);
    BytesRead := aInStream.Read(Buf, sizeof(Buf));
  end;
end;
{====================================================================}


{====================================================================}
procedure AAVigenereCipher(aEncrypt   : boolean;
                           aKey       : string;
                           aInStream  : TStream;
                           aOutStream : TStream);
var
  BytesRead : longint;
  i, j      : integer;
  Ch        : byte;
  Buf       : array [0..255] of byte;
  OutBuf    : array [0..255] of byte;
  KeyValues : array [0..255] of byte;
  KeyLen    : integer;
  KeyInx    : integer;
begin
  {the Vigenere cipher is for uppercase alphabetic letters only; in
   calculating the key values assume the key is in such a state}
  KeyLen := 0;
  for i := 1 to length(aKey) do
    if ('a' <= aKey[i]) and (aKey[i] <= 'z') then begin
      KeyValues[KeyLen] := ord(aKey[i]) - ord('a');
      inc(KeyLen);
    end
    else if ('A' <= aKey[i]) and (aKey[i] <= 'Z') then begin
      KeyValues[KeyLen] := ord(aKey[i]) - ord('A');
      inc(KeyLen);
    end;
  if not aEncrypt then
    for i := 0 to pred(KeyLen) do
      KeyValues[i] := 26 - KeyValues[i];
  {read through the input stream in blocks, encrypt the block, and
   write it to the output stream--only convert and write A-Z and a-z}
  KeyInx := 0;
  BytesRead := aInStream.Read(Buf, sizeof(Buf));
  j := 0;
  while (BytesRead > 0) do begin
    for i := 0 to pred(BytesRead) do begin
      Ch := Buf[i];
      if ((ord('A') <= Ch) and (Ch <= ord('Z'))) then begin
        OutBuf[j] := ((Ch - ord('A') + KeyValues[KeyInx]) mod 26) + ord('A');
        inc(j);
        KeyInx := (KeyInx + 1) mod KeyLen;
      end
      else if ((ord('a') <= Ch) and (Ch <= ord('z'))) then begin
        OutBuf[j] := ((Ch - ord('a') + KeyValues[KeyInx]) mod 26) + ord('A');
        inc(j);
        KeyInx := (KeyInx + 1) mod KeyLen;
      end;
    end;
    aOutStream.Write(OutBuf, j);
    BytesRead := aInStream.Read(Buf, sizeof(Buf));
    j := 0;
  end;
end;
{====================================================================}


{====================================================================}
procedure AAADFGVXCipher(aEncrypt   : boolean;
                         aKey       : string;
                   const aSubstTable: TaaADFGVXTable;
                         aInStream  : TStream;
                         aOutStream : TStream);
const
  ADFGVX : array [0..5] of char = 'ADFGVX';
var
  BytesRead : longint;
  i, j      : integer;
  Ch        : char;
  Buf       : array [0..255] of char;
  DblBuf    : array [0..511] of char;
  CleanKey  : string;
  KeyLen    : integer;
  KeyInx    : integer;
  PosCh     : integer;
  MinInx    : integer;
  ColLen    : integer;
  Row, Col  : integer;
  SubstTextSize : longint;
  InStreamSize  : longint;
  MemStream     : TMemoryStream;
begin
  {clean up the key so that it consists only of unique uppercase
   characters}
  CleanKey := '';
  for i := 1 to length(aKey) do begin
    Ch := upcase(aKey[i]);
    if ('A' <= Ch) and (Ch <= 'Z') then
      if (Pos(Ch, CleanKey) = 0) then
        CleanKey := CleanKey + Ch;
  end;
  {===ENCRYPTION===}
  if aEncrypt then begin
    {read the entire input stream, converting into letterpairs into a
     temporary stream}
    MemStream := TMemoryStream.Create;
    try
      BytesRead := aInStream.Read(Buf, sizeof(Buf));
      while (BytesRead > 0) do begin
        j := 0;
        for i := 0 to pred(BytesRead) do begin
          Ch := upcase(Buf[i]);
          if (('A' <= Ch) and (Ch <= 'Z')) or
             (('0' <= Ch) and (Ch <= '9')) then begin
            PosCh := Pos(Ch, aSubstTable) - 1;
            DblBuf[j] := ADFGVX[PosCh div 6];
            DblBuf[j+1] := ADFGVX[PosCh mod 6];
            inc(j, 2);
          end;
        end;
        MemStream.Write(DblBuf, j);
        BytesRead := aInStream.Read(Buf, sizeof(Buf));
      end;
      {now read the letters in each column according to the order of
       the letters in the cleaned key}
      KeyLen := length(CleanKey);
      for KeyInx := 1 to KeyLen do begin
        {find the smallest letter in the key, this is the column we'll
         be reading next}
        MinInx := 1;
        for i := 2 to KeyLen do
          if (CleanKey[i] < CleanKey[MinInx]) then
            MinInx := i;
        CleanKey[MinInx] := #127; {so we don't see it again}
        dec(MinInx); {it's easier with a 0-based number}

        {starting off with the MinInx'th letter in the temporary
         stream, copy it and every KeyLen'th letter after that to the
         output stream}
        SubstTextSize := MemStream.Size;
        PosCh := MinInx;
        j := 0;
        while (PosCh < SubstTextSize) do begin
          MemStream.Position := PosCh;
          inc(PosCh, KeyLen);
          MemStream.Read(DblBuf[j], 1);
          inc(j);
          if (j = sizeof(DblBuf)) then begin
            aOutStream.Write(DblBuf, sizeof(DblBuf));
            j := 0;
          end;
        end;
        if (j > 0) then
          aOutStream.Write(DblBuf, j);
      end;
    finally
      MemStream.Free;
    end;
  end
  {===DECRYPTION===}
  else begin
    {first create the memory stream we'll use as an intermediary, set
     its size to the size of the input stream}
    InStreamSize := aInStream.Size;
    MemStream := TMemoryStream.Create;
    try
      MemStream.SetSize(InStreamSize);
      {now read the letters in each column according to the order of
       the letters in the cleaned key}
      KeyLen := length(CleanKey);
      for KeyInx := 1 to KeyLen do begin
        {find the smallest letter in the key, this is the column we'll
         be reading next}
        MinInx := 1;
        for i := 2 to KeyLen do
          if (CleanKey[i] < CleanKey[MinInx]) then
            MinInx := i;
        CleanKey[MinInx] := #127; {so we don't see it again}
        dec(MinInx); {it's easier with a 0-based number}

        {calculate the length of this column}
        ColLen := InStreamSize div KeyLen;
        if ((InStreamSize - (ColLen * KeyLen)) > MinInx) then
          inc(ColLen);

        {copy the column from the input stream to the temporary
         stream, starting off by copying to the MinInx'th letter in
         the temporary stream, and every KeyLen'th letter after that;
         we stop at the end of the column}
        PosCh := MinInx;
        while (ColLen > 0) do begin
          if (ColLen > sizeof(Buf)) then
            BytesRead := aInStream.Read(Buf, sizeof(Buf))
          else
            BytesRead := aInStream.Read(Buf, ColLen);
          dec(ColLen, BytesRead);
          for i := 0 to pred(BytesRead) do begin
            MemStream.Position := PosCh;
            inc(PosCh, KeyLen);
            MemStream.Write(Buf[i], 1);
          end;
        end;
      end;
      {now read the temporary stream as letter pairs, converting them
       into the original characters for the output stream}
      MemStream.Position := 0;
      BytesRead := MemStream.Read(DblBuf, sizeof(DblBuf));
      j := 0;
      Row := 0;
      Col := 0;
      while (BytesRead > 0) do begin
        for i := 0 to pred(BytesRead) do begin
          if not Odd(i) then begin
            case DblBuf[i] of
              'A' : Row := 0;
              'D' : Row := 1;
              'F' : Row := 2;
              'G' : Row := 3;
              'V' : Row := 4;
              'X' : Row := 5;
            end;
            case DblBuf[i+1] of
              'A' : Col := 0;
              'D' : Col := 1;
              'F' : Col := 2;
              'G' : Col := 3;
              'V' : Col := 4;
              'X' : Col := 5;
            end;
            Buf[j] := aSubstTable[Row * 6 + Col + 1];
            inc(j);
            if (j = sizeof(Buf)) then begin
              aOutStream.Write(Buf, sizeof(Buf));
              j := 0;
            end;
          end;
        end;
        if (j > 0) then
          aOutStream.Write(Buf, j);
        BytesRead := MemStream.Read(DblBuf, sizeof(DblBuf));
      end;
    finally
      MemStream.Free;
    end;
  end;
end;
{--------}
function AAGenADFGVXTable : TaaADFGVXTable;
var
  i, j : integer;
  Ch   : char;
begin
  {set the result value to the letters plus digits}
  Result := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
  {now shuffle the characters in the result}
  for i := length(Result) downto 2 do begin
    j := Random(i) + 1;
    if (i <> j) then begin
      Ch := Result[i];
      Result[i] := Result[j];
      Result[j] := Ch;
    end;
  end;
end;
{====================================================================}

{====================================================================}
procedure AAXORCipher(aKey       : PByteArray;
                      aKeyLen    : integer;
                      aInStream  : TStream;
                      aOutStream : TStream);
var
  Buf    : array [0..1023] of byte;
  KeyInx : integer;
  i      : integer;
  BytesRead : longint;
begin
  {read through the input stream in blocks, XOR the block with the key
   and write it to the output stream}
  if (aKey = nil) or (aKeyLen = 0) then
    raise Exception.Create('Cannot encrypt with XOR: the key is missing');
  KeyInx := 0;
  BytesRead := aInStream.Read(Buf, sizeof(Buf));
  while (BytesRead > 0) do begin
    for i := 0 to pred(BytesRead) do begin
      Buf[i] := Buf[i] xor aKey^[KeyInx];
      KeyInx := (KeyInx + 1) mod aKeyLen;
    end;
    aOutStream.Write(Buf, BytesRead);
    BytesRead := aInStream.Read(Buf, sizeof(Buf));
  end;
end;
{====================================================================}

end.